home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
borland
/
bgiherc.zip
/
BGIDEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-05-31
|
41KB
|
1,436 lines
{ Copyright (c) 1985, 88 by Borland International, Inc. }
program BGIDemo;
(*
Turbo Pascal 5.0 Borland Graphics Interface (BGI) demonstration
program. This program shows how to use many features of the Graph unit.
Modified 2/21/89 to support the Hercules InColor Card using the Hercules
supplied HERC.BGI driver. Note that HERCULES.TPU is also used to provide
the reset procedures LoadHFNT and LoadHPAL. If you don't have HERCULES.TPU,
remove this reference from the "uses" section, and remove the LoadHFNT and
LoadHPAL statements from the code.
*)
uses
Crt, Dos, Graph, Hercules;
const
{ The five fonts available }
Fonts : array[0..4] of string[13] =
('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
{ The five predefined line styles supported }
LineStyles : array[0..4] of string[9] =
('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
{ The twelve predefined fill styles supported }
FillStyles : array[0..11] of string[14] =
('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
'InterleaveFill', 'WideDotFill', 'CloseDotFill');
{ The two text directions available }
TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
{ The Horizontal text justifications available }
HorizJust : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
{ The vertical text justifications available }
VertJust : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
var
GraphDriver : integer; { The Graphics device driver }
GraphMode : integer; { The Graphics mode value }
MaxX, MaxY : word; { The maximum resolution of the screen }
ErrorCode : integer; { Reports any graphics errors }
MaxColor : word; { The maximum color value available }
OldExitProc : Pointer; { Saves exit procedure address }
{$F+}
procedure MyExitProc;
begin
ExitProc := OldExitProc; { Restore exit procedure address }
CloseGraph; { Shut down the graphics system }
end; { MyExitProc }
{$F-}
procedure Initialize;
{ Initialize graphics and report any errors that may occur }
var
InGraphicsMode : boolean; { Flags initialization of graphics mode }
PathToDriver : string; { Stores the DOS path to *.BGI & *.CHR }
begin
{ when using Crt and graphics, turn off Crt's memory-mapped writes }
DirectVideo := False;
OldExitProc := ExitProc; { save previous exit proc }
ExitProc := @MyExitProc; { insert our exit proc in chain }
PathToDriver := '';
repeat
{$IFDEF Use8514} { check for Use8514 $DEFINE }
GraphDriver := IBM8514;
GraphMode := IBM8514Hi;
{$ELSE}
(* GraphDriver := DETECT; { use autodetection } *)
GraphDriver := HERCMONO; { If the Hercules card is not }
{$ENDIF} { the ONLY adapter in the system }
{ the BGI autodetect function may }
{ fail. To accommodate the case }
{ of the Hercules InColor Card }
{ alongside the Hercules VGA Card }
{ this code forces the driver }
{ to Hercules. }
InitGraph(GraphDriver, GraphMode, PathToDriver);
ErrorCode := GraphResult; { preserve error return }
if ErrorCode <> grOK then { error? }
begin
Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
if ErrorCode = grFileNotFound then { Can't find driver file }
begin
Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
Readln(PathToDriver);
Writeln;
end
else
Halt(1); { Some other error: terminate }
end;
until ErrorCode = grOK;
Randomize; { init random number generator }
MaxColor := GetMaxColor; { Get the maximum allowable drawing color }
MaxX := GetMaxX; { Get screen resolution values }
MaxY := GetMaxY;
end; { Initialize }
function Int2Str(L : LongInt) : string;
{ Converts an integer to a string for use with OutText, OutTextXY }
var
S : string;
begin
Str(L, S);
Int2Str := S;
end; { Int2Str }
function RandColor : word;
{ Returns a Random non-zero color value that is within the legal
color range for the selected device driver and graphics mode.
MaxColor is set to GetMaxColor by Initialize }
begin
RandColor := Random(MaxColor)+1;
end; { RandColor }
procedure DefaultColors;
{ Select the maximum color in the Palette for the drawing color }
begin
SetColor(MaxColor);
end; { DefaultColors }
procedure DrawBorder;
{ Draw a border around the current view port }
var
ViewPort : ViewPortType;
begin
DefaultColors;
SetLineStyle(SolidLn, 0, NormWidth);
GetViewSettings(ViewPort);
with ViewPort do
Rectangle(0, 0, x2-x1, y2-y1);
end; { DrawBorder }
procedure FullPort;
{ Set the view port to the entire screen }
begin
SetViewPort(0, 0, MaxX, MaxY, ClipOn);
end; { FullPort }
procedure MainWindow(Header : string);
{ Make a default window and view port for demos }
begin
DefaultColors; { Reset the colors }
ClearDevice; { Clear the screen }
SetTextStyle(DefaultFont, HorizDir, 1); { Default text font }
SetTextJustify(CenterText, TopText); { Left justify text }
FullPort; { Full screen view port }
OutTextXY(MaxX div 2, 2, Header); { Draw the header }
{ Draw main window }
SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
DrawBorder; { Put a border around it }
{ Move the edges in 1 pixel on all sides so border isn't in the view port }
SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end; { MainWindow }
procedure StatusLine(Msg : string);
{ Display a status line at the bottom of the screen }
begin
FullPort;
DefaultColors;
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
SetLineStyle(SolidLn, 0, NormWidth);
SetFillStyle(EmptyFill, 0);
Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY); { Erase old status line }
Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
{ Go back to the main window }
SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
end; { StatusLine }
procedure WaitToGo;
{ Wait for the user to abort the program or continue }
const
Esc = #27;
var
Ch : char;
begin
StatusLine('Esc aborts or press a key...');
repeat until KeyPressed;
Ch := ReadKey;
if ch = #0 then ch := readkey; { trap function keys }
if Ch = Esc then
begin
LoadHFNT;
LoadHPAL;
Halt(0); { terminate program }
end
else
ClearDevice; { clear screen, go on with demo }
end; { WaitToGo }
procedure GetDriverAndMode(var DriveStr, ModeStr : string);
{ Return strings describing the current device driver and graphics mode
for display of status report }
begin
DriveStr := GetDriverName;
ModeStr := GetModeName(GetGraphMode);
end; { GetDriverAndMode }
procedure ReportStatus;
{ Display the status of all query functions after InitGraph }
const
X = 10;
var
ViewInfo : ViewPortType; { Parameters for inquiry procedures }
LineInfo : LineSettingsType;
FillInfo : FillSettingsType;
TextInfo : TextSettingsType;
Palette : PaletteType;
DriverStr : string; { Driver and mode strings }
ModeStr : string;
Y : word;
procedure WriteOut(S : string);
{ Write out a string and increment to next line }
begin
OutTextXY(X, Y, S);